home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / qwik55.zip / QWIKDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1989-08-24  |  24KB  |  713 lines
  1. { =========================================================================== }
  2. { QwikDemo.pas - Demo program for QWIK screen utilities.    ver 5.5, 08-24-89 }
  3. { Demo has been programmed best for color cards in 25-line mode.              }
  4. { =========================================================================== }
  5.  
  6. program QwikDemo;
  7.  
  8. { R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }       { TP4 directives }
  9. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}  { TP5 directives }
  10. {$M 12000, 0, 0}
  11.  
  12. uses
  13.   Crt,Qwik,Strs;
  14.  
  15. type
  16.   BrdrRec =
  17.     record                 { For Qbox procedure }
  18.       TL,TH,TR,LV,RV,BL,BH,BR: char;
  19.     end;
  20.  
  21. var
  22.   Row,Rows,Col,Cols,Step,ColMax: byte;
  23.   i,Count,
  24.   Fgrnd,Bgrnd:         word;
  25.   BrdrAttr, WndwAttr:  integer;
  26.   SavedBlock, PopUpBlock: array [1..4000] of byte;
  27.   BlkRow,BlkCol,V:               byte;
  28.   ColL,ColR: array [1..3] of byte;
  29.   Strng,Strng2:          string[75];
  30.   Data: array [1..9 ] of string[40];
  31.   PC:   array [1..14] of string[40];
  32.   Init: array [1..10] of string[40];
  33.   Other:array [1..12] of string[40];
  34.   Crsr: array [1..13] of string[40];
  35.   Eoss: array [1.. 4] of string[40];
  36.   Rnum:                  Real;
  37.   Ch:                    char;
  38.   LastVideoMode:         byte;
  39.  
  40. const
  41.   Wait: word = 400;      { One unit of wait in milliseconds for demo. }
  42.   { These are double lines for Qbox }
  43.   Border: BrdrRec =  (TL:'╔';TH:'═';TR:'╗';
  44.                       LV:'║';       RV:'║';
  45.                       BL:'╚';BH:'═';BR:'╝');
  46.   BWcolors: array[0..3] of byte = (
  47.               Black,        { Black     on Black }
  48.               LightGray,    { LightGray on Black }
  49.               White,        { White     on Black }
  50.               LightGrayBG); { Black     on LightGray }
  51.  
  52. { Since Zenith doesn't have snow on any CGAs, turn off snow checking }
  53. procedure CheckZenith;
  54. var  ZdsRom: array[1..8] of char absolute $F000:$800C;
  55. begin
  56.   if Qsnow and (ZdsRom='ZDS CORP') then
  57.     begin
  58.       Qsnow    := false;
  59.       CardSnow := false;
  60.     end;
  61. end;
  62.  
  63. { Qbox is an application of QWIK screen utilities.  It can make fast
  64.   pop-up menus.  See WNDWxx.ARC for more applications. }
  65. procedure Qbox (Row,Col,Rows,Cols: byte; WndwAttr,BrdrAttr: integer;
  66.                                                       Brdr: BrdrRec);
  67. begin
  68.   if (Rows>=2) and (Cols>=2) then
  69.   begin
  70.     with Brdr do
  71.     begin
  72.       Qwrite    (Row       ,Col                     ,BrdrAttr,TL);
  73.       QfillEos  (                           1,Cols-2,BrdrAttr,TH);
  74.       QwriteEos (                                    BrdrAttr,TR);
  75.       Qfill     (Row+1     ,Col       ,Rows-2,1     ,BrdrAttr,LV);
  76.       Qfill     (Row+1     ,Col+Cols-1,Rows-2,1     ,BrdrAttr,RV);
  77.       Qwrite    (Row+Rows-1,Col                     ,BrdrAttr,BL);
  78.       QfillEos  (                           1,Cols-2,BrdrAttr,BH);
  79.       QwriteEos (                                    BrdrAttr,BR);
  80.       Qfill     (Row+1     ,Col+1     ,Rows-2,Cols-2,WndwAttr,' ')
  81.     end
  82.   end
  83. end;
  84.  
  85. procedure CloseDemo;
  86. begin
  87.   if QVideoMode<=CO40 then
  88.     begin
  89.       if LastVideoMode>CO40 then
  90.         delay (Wait*4);
  91.       TextMode (LastVideoMode+hi(LastMode));
  92.     end;
  93.   GotoRC (23, 1);
  94.   SetCursor (CursorInitial);
  95. end;
  96.  
  97. procedure PromptKey;
  98. begin
  99.   Qwrite (25,CRTcols-19,SameAttr,'press any key ...');
  100.   Ch := ReadKey;
  101.   if Ch=#27 then
  102.     begin
  103.       CloseDemo;
  104.       Halt;
  105.     end;
  106. end;
  107.  
  108. procedure ClearScreen (Attr: integer);
  109. begin
  110.   Qfill ( 1, 1,CRTrows,CRTcols,Attr,' ');
  111. end;
  112.  
  113. procedure ExplodeBoxes;
  114. var
  115.   TopRow,BottomRow,MaxRows,MaxCols,DeltaCols,LeftCol,RightCol: byte;
  116.   CenterCol:    byte;
  117.   ClockReading: word absolute $0040:$006C; { low memory clock }
  118.   StartTime:    word;
  119.  
  120. {}procedure ScatterBoxes;
  121. {}begin
  122. {}  Rows:= succ(random(MaxRows));
  123. {}  if QVideoMode<=CO40 then              { Keep aspect 1:1 }
  124. {}       Cols:= Rows + Rows shr 2         { 1.2 cols/row }
  125. {}  else Cols:= Rows shl 1 + Rows shr 1;  { 2.4 cols/row }
  126. {}  Col := LeftCol + random (RightCol-LeftCol-Cols+2);
  127. {}  Row := TopRow  + random (BottomRow-TopRow-Rows+2);
  128. {}  if QVideoMode=Mono then
  129. {}  TextAttr:=BWcolors[(random(4))]
  130. {}  else
  131. {}    begin
  132. {}      Fgrnd:= random (16);
  133. {}      Bgrnd:= random (8);
  134. {}      if Bgrnd=Fgrnd then inc(Fgrnd);
  135. {}      TextAttr:=Fgrnd + Bgrnd shl 4;
  136. {}    end;
  137. {}  Qfill (Row,Col,Rows,Cols,TextAttr,#178);
  138. {}end;
  139.  
  140. begin
  141.   CenterCol:=CRTcols shr 1;
  142.   randomize;
  143.   StartTime:=ClockReading;
  144.   for Step:=1 to 12 do
  145.     begin
  146.       { Set boundaries }
  147.       TopRow:=13-Step;
  148.       BottomRow:=13+Step;
  149.       MaxRows:=Step;
  150.       if QVideoMode<=CO40 then                      { Keep aspect 1:1 }
  151.         begin
  152.           MaxCols:= MaxRows + MaxRows shr 2;        { 1.2 cols/row }
  153.           DeltaCols:=(Step*5 div 3);
  154.         end
  155.       else
  156.         begin
  157.           MaxCols:= MaxRows shl 1 + MaxRows shr 1;  { 2.4 cols/row }
  158.           DeltaCols:=(Step*10 div 3);
  159.         end;
  160.       LeftCol  :=succ(CenterCol)-DeltaCols;
  161.       RightCol :=CenterCol+DeltaCols;
  162.       if Step<12 then
  163.         begin
  164.           for Count:=1 to 40 do ScatterBoxes;
  165.         end
  166.       else
  167.         repeat
  168.           ScatterBoxes;
  169.         until ClockReading-StartTime>=60;  { about 60/18.2 seconds }
  170.     end;
  171. end;
  172.  
  173. procedure InitDemo;
  174. begin
  175. { --- Set up data --- }
  176. { If you set a mode, do it first before Qinit! }
  177. { Please!  Test a mode first to see if it is different than what you want; }
  178. { then change if necessary.  Otherwise, the screen jumps. }
  179.  
  180.   CheckBreak := false;
  181.   CheckZenith;
  182.   SetMultiTask;
  183.   LastVideoMode := QVideoMode;
  184.   if (QVideoMode<>Mono) and not Have3270 then
  185.     begin
  186.       ClearScreen (LightGray+BlackBG);
  187.       QwriteC (11,1,CRTcols,SameAttr,'(1) 40 column mode');
  188.       QwriteC (12,1,CRTcols,SameAttr,'(2) 80 column mode');
  189.       QwriteC (14,1,CRTcols,SameAttr,'Which mode [1,2]? ');
  190.       GotoEos;
  191.       repeat
  192.         Ch:=ReadKey;
  193.       until ch in ['1','2'];
  194.       V := QVideoMode;
  195.       case ch of
  196.         '1': case V of
  197.                BW80: V:=BW40;
  198.                CO80: V:=CO40;
  199.              end;
  200.         '2': case V of
  201.                BW40: V:=BW80;
  202.                CO40: V:=CO80;
  203.              end;
  204.       end;
  205.       if V<>QVideoMode then
  206.         begin
  207.           TextMode (V+hi(LastMode));
  208.           Qinit;           { << Do Qinit again after change of mode!! }
  209.           CheckZenith;
  210.           SetMultiTask;
  211.         end;
  212.     end;
  213.   ModCursor (CursorOff);
  214.   Strng:=   ' Q Screen Utilities ';
  215.   Strng2:=  ' QWIK Screen Utilities  ';
  216.   Data[1]:= '1';
  217.   Data[2]:= '22';
  218.   Data[3]:= '333';
  219.   Data[4]:= Strng;
  220.   Data[5]:= 'Odd  Length';
  221.   Data[6]:= 'Even  Length';
  222.   Data[7]:= '18 characters wide';
  223.   Data[8]:= '19 characters width';
  224.   Data[9]:= 'Margin to Margin width';
  225.   PC[1]:=  'COMPUTERS:           ADAPTERS:';
  226.   PC[2]:=  '------------------   ----------';
  227.   PC[3]:=  'IBM PC               MDA';
  228.   PC[4]:=  'IBM XT               CGA';
  229.   PC[5]:=  'IBM AT               EGA';
  230.   PC[6]:=  'IBM PCjr             MCGA';
  231.   PC[7]:=  'IBM PC Convertible   VGA';
  232.   PC[8]:=  'IBM PS/2 Model 25    8514/A';
  233.   PC[9]:=  'IBM PS/2 Model 30    Hercules:';
  234.   PC[10]:= 'IBM PS/2 Model 50      HGC';
  235.   PC[11]:= 'IBM PS/2 Model 60      HGC Plus';
  236.   PC[12]:= 'IBM PS/2 Model 70      InColor';
  237.   PC[13]:= 'IBM PS/2 Model 80';
  238.   PC[14]:= 'IBM 3270 PC';
  239.   Other[ 1]:='QscrollUp  - Qwik scroll up';
  240.   Other[ 2]:='QscrollDown- Qwik scroll down';
  241.   Other[ 3]:='QscrToVscr - block to virtual screen';
  242.   Other[ 4]:='QVscrToScr - virtual screen to block';
  243.   Other[ 5]:='QreadStr   - reads string from screen';
  244.   Other[ 6]:='QreadChar  - reads char   from screen';
  245.   Other[ 7]:='QreadAttr  - reads attr   from screen';
  246.   Other[ 8]:='QviewPage  - view any video page';
  247.   Other[ 9]:='QwritePage - write to any video page';
  248.   Other[10]:='QwriteA    - for arrays/partial strings';
  249.   Other[11]:='QfillC     - a self-centering Qfill';
  250.   Other[12]:='QattrC     - a self-centering Qattr';
  251.   Crsr[ 1]:='GotoRC        - absolute cursor position';
  252.   Crsr[ 2]:='WhereR        - absolute cursor row';
  253.   Crsr[ 3]:='WhereC        - ab